Otherware/Otherware_1_SB_Development.iso/mac/util/comm/converse.sit/NSCA Converse/PatientDoctorRelations

Text File | 1991-04-02 | 4.7 KB | 264 lines

unit PatientDoctorRelations;

interface

    uses
        AppleTalk;

    procedure OpenSocket;
    function GetAddress: boolean;
    procedure Talk (s: string);
    procedure StartRead;
    procedure Hear (var s: string);
    procedure CloseSocket;
    procedure GetOutOfHere (i, j: integer);

implementation

    var
        abRecord, abReadRecord: ABRecHandle;
        RegisterBuffer: ptr;
        address: AddrBlock;
        mySocket: byte;
        myEntity: EntityName;
        ReceiveBuffer: ptr;

    procedure GetOutOfHere (i, j: integer);
    begin
        showtext;
        writeln(i, j);
        repeat
        until button;
        exittoshell;
    end;

    procedure OpenSocket;
        var
            err: integer;
            UniqueName: integer;

    begin
        UniqueName := 0;

        mySocket := 0;
        err := DDPOpenSocket(mySocket, nil);
        if err <> 0 then
            getoutofhere(1, err);

        abRecord := ABRecHandle(NewHandle(ddpSize));
        if abRecord = nil then
            getoutofhere(2, err);

        abReadRecord := ABRecHandle(NewHandle(ddpSize));
        if abReadRecord = nil then
            getoutofhere(3, err);

        RegisterBuffer := newptr(200);
        if RegisterBuffer = nil then
            getoutofhere(4, err);

        ReceiveBuffer := newptr(250);
        if ReceiveBuffer = nil then
            getoutofhere(5, err);

        HLock(handle(abRecord));

        repeat
            UniqueName := UniqueName + 1;
            with myEntity do
                begin
                    objStr := concat('Lucy', StringOf(UniqueName : 1));
                    typeStr := 'Doctor';
                    zoneStr := '*';
                end;

            repeat
                err := NBPRemove(@myEntity)
            until err <> 0;

            with abRecord^^ do
                begin
                    nbpEntityPtr := @myEntity;
                    nbpBufPtr := RegisterBuffer;
                    nbpBufSize := 200;
                    nbpAddress.aSocket := mySocket;
                    with nbpRetransmitInfo do
                        begin
                            retransInterval := 8;
                            retransCount := 3;
                        end;
                end;

            err := NBPRegister(abRecord, false);

        until err <> -1027;  {nbpDuplicate}

        HUnLock(handle(abRecord));

        if err <> 0 then
            getoutofhere(6, err);

    end;

    function GetAddress: boolean;
        var
            Entity: EntityName;
            buffer: ptr;
            err: integer;

        procedure punt;
        begin
            disposPtr(buffer);
            exit(GetAddress);
        end;

    begin
        GetAddress := false;

        buffer := newptr(200);
        if buffer = nil then
            exit(GetAddress);

        with Entity do
            begin
                objStr := '=';
                typeStr := 'Doctor';
                zoneStr := '*';
            end;

        HLock(handle(abRecord));

        with abRecord^^ do
            begin
                abUserReference := 0;
                nbpEntityPtr := @Entity;
                nbpBufPtr := buffer;
                nbpBufSize := 200;
                nbpDataField := 1;
                with nbpRetransmitInfo do
                    begin
                        retransInterval := 8;
                        retransCount := 1;
                    end;
            end;

        err := NBPLookup(abRecord, false);
        if err <> 0 then
            getoutofhere(7, err);

        HUnLock(handle(abRecord));

        if abRecord^^.nbpDataField = 0 then
            punt;

        if abRecord^^.nbpDataField <> 1 then
            getoutofhere(8, err);


        err := NBPExtract(buffer, 1, 1, Entity, address);
        if err <> 0 then
            getoutofhere(9, err);

        GetAddress := true;
    end;

    procedure Talk (s: string);
        var
            err: integer;

    begin

        HLock(handle(abRecord));

        with abRecord^^ do
            begin
                ddpType := 166;
                ddpSocket := mySocket;
                ddpAddress := address;
                ddpReqCount := length(s);
                ddpDataPtr := @s[1];
            end;

        err := DDPWrite(abRecord, false, false);
        if err <> 0 then
            getoutofhere(10, err);

        HUnLock(handle(abRecord));

    end;

    procedure StartRead;
        var
            err: integer;
    begin

        HLock(handle(abReadRecord));

        with abReadRecord^^ do
            begin
                ddpSocket := mySocket;
                ddpReqCount := 250;
                ddpDataPtr := ReceiveBuffer;
            end;

        err := DDPRead(abReadRecord, false, true);
        if err <> 0 then
            getoutofhere(11, err);

        HUnLock(handle(abReadRecord));

    end;

    procedure Hear (var s: string);
        var
            err: integer;
    begin

        HLock(handle(abReadRecord));

        if abReadRecord^^.abResult <> 0 then
            getoutofhere(12, err);

        if abReadRecord^^.ddpType <> 166 then
            getoutofhere(13, err);

        address.aNet := abReadRecord^^.ddpAddress.aNet;
        address.aNode := abReadRecord^^.ddpAddress.aNode;
        address.aSocket := abReadRecord^^.ddpAddress.aSocket;

        if (abReadRecord^^.ddpActCount < 0) or (abReadRecord^^.ddpActCount > 200) then
            getoutofhere(18, err);

        if abReadRecord^^.ddpActCount = 0 then
            s := ''
        else
            begin
                s := '01234567890123456789012345678901234567890123456789';        {50 characters}
                s := concat(s, s, s, s, s);            {250 characters}
                BlockMove(ReceiveBuffer, @s[1], abReadRecord^^.ddpActCount);
                s := Copy(s, 1, abReadRecord^^.ddpActCount);
            end;

        HUnLock(handle(abReadRecord));

    end;

    procedure CloseSocket;
        var
            err: integer;
    begin
        err := NBPRemove(@myEntity);
        if err <> 0 then
            getoutofhere(19, err);

        err := DDPCloseSocket(mySocket);
        if err <> 0 then
            getoutofhere(20, err);

        DisposHandle(handle(abRecord));
        DisposHandle(handle(abReadRecord));
        DisposPtr(RegisterBuffer);
        DisposPtr(ReceiveBuffer);
    end;

end.